Delphi 2.0 - Programmer's Utilities Power Pack/Delphi 2.0 Programmer's Utilities Power Pack.iso/m_to_r/pichrt10/piechart.pas

Pascal/Delphi Source File | 1996-09-15 | 12.8 KB | 480 lines

unit PieChart;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

// the objects on our local string list contain both the original
// object and the real number which is the value of the data
type
  TObjectAndDouble = class(TObject)
    source_object: TObject;
    value: double;
  end;

type
  TStringListWithDouble = class(TStringList)
    destructor Destroy;  override;
  end;

const
  min_height = 65;
  min_width = 65;

type
  TPieChart = class(TGraphicControl)
  private
    { Private declarations }
    FData: TStringListWithDouble; // computed internal data
    FListBox: TListBox;
    FOnDblClick: TNotifyEvent;
    FMouseX, FMouseY: integer;
    FTotal: double;
    FColour1: TColor;
    FColour2: TColor;
    FColour3: TColor;
    FColour4: TColor;
    FColour5: TColor;
    FColour6: TColor;
    procedure SetListBox (ListBox: TListBox);
  protected
    { Protected declarations }
    procedure Paint;  override;
    procedure DblClick;  override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);  override;
  public
    { Public declarations }
    ClickedObject: TObject;
    constructor Create (AOwner: TComponent);  override;
    destructor Destroy;  override;
    procedure SetDataAndLabels (source_data: TStringList);
    procedure SetColour1 (colour: TColor);
    procedure SetColour2 (colour: TColor);
    procedure SetColour3 (colour: TColor);
    procedure SetColour4 (colour: TColor);
    procedure SetColour5 (colour: TColor);
    procedure SetColour6 (colour: TColor);
    procedure Clear;
  published
    { Published declarations }
    property Height default min_height;
    property Width default min_width;
    property Colour1: TColor read FColour1 write SetColour1;
    property Colour2: TColor read FColour2 write SetColour2;
    property Colour3: TColor read FColour3 write SetColour3;
    property Colour4: TColor read FColour4 write SetColour4;
    property Colour5: TColor read FColour5 write SetColour5;
    property Colour6: TColor read FColour6 write SetColour6;
    property Font;
    property ParentFont;
    property ListBox: TListBox read FListBox write SetListBox;
    property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Davids', [TPieChart]);
end;

destructor TStringListWithDouble.Destroy;
var
  index: integer;
begin
  for index := 0 to Count - 1 do
    if Objects [index] <> nil then Objects [index].Free;
  Inherited Destroy;
end;

constructor TPieChart.Create (AOwner: TComponent);
var
  lst: TStringList;
begin
  Inherited Create (AOwner);
  Width := min_width;
  Height := min_height;
  FData := TStringListWithDouble.Create;
  FData.Sorted := False;
  FData.Duplicates := dupAccept;
  FListBox := nil;
  FTotal := 0.0;
  FColour1 := RGB ($FF, $E0, $E0);
  FColour2 := RGB ($FF, $FF, $E0);
  FColour3 := RGB ($E0, $FF, $E0);
  FColour4 := RGB ($E0, $FF, $FF);
  FColour5 := RGB ($E0, $E0, $FF);
  FColour6 := RGB ($FF, $E0, $FF);
  if csDesigning in ComponentState then
    begin
    lst := TStringList.Create;
    lst.Add ('4 Smallest');
    lst.Add ('6 Smaller');
    lst.Add ('9 Small');
    lst.Add ('11 Large');
    lst.Add ('14 Larger');
    lst.Add ('17 Largest');
    SetDataAndLabels (lst);
    lst.Free;
    end;
end;

destructor TPieChart.Destroy;
begin
  FData.Free;
  Inherited Destroy;
end;

procedure TPieChart.SetListBox (ListBox: TListBox);
begin
  FListBox := ListBox;
end;

procedure TPieChart.SetColour1 (colour: TColor);
begin
  FColour1 := colour;
  Invalidate;
end;

procedure TPieChart.SetColour2 (colour: TColor);
begin
  FColour2 := colour;
  Invalidate;
end;

procedure TPieChart.SetColour3 (colour: TColor);
begin
  FColour3 := colour;
  Invalidate;
end;

procedure TPieChart.SetColour4 (colour: TColor);
begin
  FColour4 := colour;
  Invalidate;
end;

procedure TPieChart.SetColour5 (colour: TColor);
begin
  FColour5 := colour;
  Invalidate;
end;

procedure TPieChart.SetColour6 (colour: TColor);
begin
  FColour6 := colour;
  Invalidate;
end;

procedure TPieChart.Clear;
begin
  FData.Clear;
  if FListBox <> nil
    then FListBox.Clear;   // remove any items in the list box
  Invalidate;
end;

procedure TPieChart.SetDataAndLabels (source_data: TStringList);

  procedure QuickSort (L, R: Integer);
  // sorts FData into reverse numerical order
  var
    I, J: integer;
    X: double;
  begin
    I := L;
    J := R;
    X := TObjectAndDouble (FData.Objects [(L + R) shr 1]).Value;
    repeat
      while TObjectAndDouble (FData.Objects[I]).Value > X do Inc(I);
      while TObjectAndDouble (FData.Objects[J]).Value < X do Dec(J);
      if I <= J then
      begin
        FData.Exchange(I, J);
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then QuickSort(L, J);
    if I < R then QuickSort(I, R);
  end;

var
  index: integer;
  d: double;
  s: string;
  num: string;
  lbl: string;
  space: integer;
  code: integer;
  dd: TObjectAndDouble;
begin
  FData.Clear;
  if FListBox <> nil
    then FListBox.Clear;   // remove any items in the list box

  FTotal := 0.0;
  for index := 0 to source_data.Count - 1 do
    begin
    s := Trim (source_data.Strings[index]);       // get the source string
    space := Pos (' ', s);
    if space = 0
    then
      begin
      num := s;
      lbl := '';                // assume no label part
      end
    else
      begin
      lbl := Trim (Copy (s, space, 999));
      num := Copy (s, 1, space-1);
      end;
    Val (num, d, code);
    if code = 0
    then
      begin
      FTotal := FTotal + d;
      dd := TObjectAndDouble.Create;
      dd.value := d;
      dd.source_object := source_data.Objects[index];
      FData.AddObject (s, dd);
      end
    else
      dd := nil; // should we raise an error here?
    end;
  if FData.Count <> 0 then
    begin
    QuickSort (0, FData.Count - 1);
    if FListBox <> nil then
      // copy the user's strings and objects to the list box
      for index := 0 to FData.Count - 1 do
         FListBox.Items.AddObject (
             FData.strings[index],
             TObjectAndDouble (Fdata.objects[index]).source_object);
    end;
  Invalidate;
end;

procedure TPieChart.MouseDown (Button: TMouseButton; Shift: TShiftState;
                               X, Y: Integer);
begin
  {record the mouse co-ordinates in case of a double-click}
  FMouseX := X;
  FMouseY := Y;
end;

procedure TPieChart.DblClick;

  function atan2 (y, x: double): double;
  var
     a: double;
  begin
    if x = 0.0
      then
        if y < 0.0
          then atan2 := -pi / 2 else atan2 := pi / 2
      else
        if y = 0.0
          then
            if x < 0.0
              then atan2 := pi else atan2 := 0.0
          else
            begin
            a := arctan (abs (y/x));
            if x > 0.0
              then
                if y > 0.0
                  then atan2 := a else atan2 := -a
            else
                if y > 0.0
                  then atan2 := pi - a else atan2 := -(pi - a)
            end;
  end;

var
   found: boolean;
   desired: integer;
   x, y: integer;
   dx, dy, dr: double;
   pie_radius: double;
   index: integer;
   test_theta, theta, d_theta, next_theta: double;
   d: double;
begin
  Inherited Click;
  if Assigned (FOnDblClick) then
    begin
    {find out where we were clicked - in client co-ordinates}
    {translate this relative to the centre of the pie chart}
    dx := FMouseX - Width div 2;
    dy := Height div 2 - FMouseY;
    dr := sqrt (sqr (dx) + sqr (dy));
    pie_radius := Width div 2;
    if Height > Width then pie_radius := Height;

    if (dr < pie_radius) and (FData.Count <> 0) then
      begin
      theta := atan2 (dy, dx);
      if theta < 0.0 then theta := theta +  2.0 * pi;
      test_theta := 0.0;
      found := false;
      index := FData.Count - 1;
      index := 0;
      while (not found) and (index < FData.Count) do
        begin
        d := TObjectAndDouble (FData.Objects [index]).Value;
        d_theta := (2.0 * pi * d) / FTotal;
        next_theta := test_theta + d_theta;
        found := (theta > test_theta) and (theta < next_theta);
        if found
          then desired := index
          else
          begin
          test_theta := next_theta;
          Inc (index);
          end;
        end;
      if found then
        begin
        ClickedObject := TObjectAndDouble (FData.Objects [index]).source_object;
        FOnDblClick (Self);
        end;
      end;
    end;
end;

procedure TPieChart.Paint;
const
  radius = 1000;    {nominal radius just for line edges}
var
  colour_number: byte;
  theta, next_theta, d_theta: double;
  x0, y0: integer;
  x, y: integer;
  x1, y1: integer;

  procedure draw_label (const s: string);
  var
    pie_radius: integer;
    semi_width, semi_height: integer;
    x_mid, y_mid, x1, x2, y1, y2: integer;
    mid_theta: double;
    max_radius: double;
    text_radius: double;
    OldBkMode: integer;
  begin
    if (d_theta > 0.13) and (length (s) <> 0) then
      begin
      OldBkMode := SetBkMode(Canvas.Handle, TRANSPARENT);
      if Width < Height
        then pie_radius := Width div 2
        else pie_radius := Height div 2;
      semi_width := Canvas.TextWidth (s) div 2;
      semi_height := Canvas.TextHeight (s) div 2;
      mid_theta := (theta + next_theta) / 2.0;
      {compute the central point, if it was on the rim}
      x_mid := x0 + round (pie_radius * cos (mid_theta));
      y_mid := y0 - round (pie_radius * sin (mid_theta));
      {compute the bounding rectangle}
      x1 := x_mid - semi_width;  x2 := x_mid + semi_width;
      y1 := y_mid - semi_height;  y2 := y_mid + semi_height;
      {find the maximum radius from the centre to the four corners of the bounding rectangle}
      max_radius := 0.0;
      text_radius := round (sqrt (sqr (x1 - x0) + sqr (y1 - y0)));
      if text_radius > max_radius then max_radius := text_radius;
      text_radius := round (sqrt (sqr (x2 - x0) + sqr (y1 - y0)));
      if text_radius > max_radius then max_radius := text_radius;
      text_radius := round (sqrt (sqr (x1 - x0) + sqr (y2 - y0)));
      if text_radius > max_radius then max_radius := text_radius;
      text_radius := round (sqrt (sqr (x2 - x0) + sqr (y2 - y0)));
      if text_radius > max_radius then max_radius := text_radius;
      {compute the text radius that will just fit inside the circle}
      text_radius := 2.0 * pie_radius - max_radius;
      x_mid := x0 + round (text_radius * cos (mid_theta));
      y_mid := y0 - round (text_radius * sin (mid_theta));
      Canvas.TextOut (x_mid - semi_width, y_mid - semi_height, s);
      SetBkMode(Canvas.Handle, OldBkMode);
      end;
  end;

  procedure draw_pie_segment;
  const
    num_colours = 6;
  begin
    if (x <> x1) or (y <> y1) or (d_theta > 0.15) then
      begin
      case colour_number of
        0: Canvas.Brush.Color := FColour1;
        1: Canvas.Brush.Color := FColour2;
        2: Canvas.Brush.Color := FColour3;
        3: Canvas.Brush.Color := FColour4;
        4: Canvas.Brush.Color := FColour5;
        5: Canvas.Brush.Color := FColour6;
      end;
      Inc (colour_number);
      colour_number := colour_number mod num_colours;
      Canvas.Pie (0, 0, Width, Height, x, y, x1, y1);
      end;
  end;

  procedure compute_segment (delta: double;  s: string;  do_pie: boolean);
  const
    num_colours = 6;
  begin
    d_theta := (2.0 * pi * delta) / FTotal;
    next_theta := theta + d_theta;
    x1 := x0 + round (radius * cos (next_theta));
    y1 := y0 - round (radius * sin (next_theta));
    if do_pie
      then draw_pie_segment
      else draw_label (s);
    theta := next_theta;
    x := x1;
    y := y1;
  end;

var
  d: double;
  index: integer;
  s: string;
  space: integer;
begin
  x0 := Width div 2;
  y0 := Height div 2;
  Canvas.Pen.Color := clBlack;
  if FTotal > 0.0 then
    begin
    colour_number := 0;
    x := x0 + radius;
    y := y0;
    theta := 0.0;
    for index := 0 to FData.Count - 1 do
      begin
      d := TObjectAndDouble (FData.Objects [index]).Value;
      compute_segment (d, '', true);
      end;
    x := x0 + radius;
    y := y0;
    theta := 0.0;
    Canvas.Font := Self.Font;
    Canvas.Font.Color := clBlack;
    for index := 0 to FData.Count - 1 do
      begin
      d := TObjectAndDouble (FData.Objects [index]).Value;
      s := Trim (FData.Strings [index]);
      space := Pos (' ', s);
      if space = 0
      then s := ''
      else s := Trim (Copy (s, space, 999));
      compute_segment (d, s, false);
      end;
    end;
end;

end.